;; -*- emacs-lisp -*-

(require 'gdb-ui)
(defvar eip-perl-db-buffer nil
  "the name of debuging buffer")

(defun eip-perl-db ()
  (interactive)
  (setq eip-perl-db-buffer (current-buffer))
  (cperl-db))

(defun eip-perl-db-current-buffer ()
  (interactive)
  (setq eip-perl-db-buffer (current-buffer))
  (perldb (concat "perl -d " (buffer-file-name))))

(defun eip-perl-current-buffer ()
  (interactive)
  (setq eip-perl-db-buffer (current-buffer))
  (perldb (concat "perl " (buffer-file-name))))

(defadvice gud-perldb-marker-filter (before eip-perldb-marker-filter
					    (string))
  "Check the perl breakpoint available"
  (let ((eip-marker string))
    (if (string-match "Line \\(\\([0-9]+\\)\\) not breakable.\n" eip-marker)
	(progn
	  (let (num1 (string-to-number (match-string 1 eip-marker)))
	    (message (concat "remove breakpoint on line " (match-string 1 eip-marker)))
	    (eip-display-breakpoint nil (string-to-number (match-string 1 eip-marker)))
	    )
	  ;
	  (setq string (substring eip-marker (match-end 0)))
	  ))))

;; executed when process goes down
(defadvice gud-sentinel (before eip-gud-perldb-sentinel (proc msg))  ;; clear all breakpoints
  "Clear all perl breakpoints"
  ;(messages "clear perl breakpoints")
  (with-current-buffer eip-perl-db-buffer
  (save-excursion
    (save-restriction
      (widen)
      (let ((es (overlays-in 1 (1+ (point-max)))))
	(mapc (lambda (e) 
                (if (overlay-get e 'eip-perldb-break)
		    (delete-overlay e)))
	      es))))))

(defadvice gud-call (before eip-gud-call (fmt &optional arg))
  (let ((eip-msg (gud-format-command fmt arg)))
    (let ((args (split-string eip-msg)))
      (eip-set-breakpoint args))))
    


(ad-activate 'gud-perldb-marker-filter)
(ad-activate 'gud-sentinel)
(ad-activate 'gud-call)

(defun eip-put-string (putstring pos &optional dprop &rest sprops)
  "Put string PUTSTRING in front of POS in the current buffer.
PUTSTRING is displayed by putting an overlay into the current buffer with a
`before-string' string that has a `display' property whose value is
PUTSTRING."
  (let ((string (make-string 1 ?x))
	(buffer (current-buffer)))
    (setq putstring (copy-sequence putstring))
    (let ((overlay (make-overlay pos (1+ pos) buffer))
	  (prop (or dprop
		    (list (list 'margin 'left-margin) putstring))))
      (put-text-property 0 1 'display prop string)
      (if sprops
	  (add-text-properties 0 1 sprops string))
      (overlay-put overlay 'eip-perldb-break t)
      (overlay-put overlay 'before-string string))))


(defun eip-display-breakpoint (enabled line &rest sprops)
   (interactive)
   (let ((buff-name (buffer-name)))
     ;(message (number-to-string line))
     (let ((len (length buff-name)))
       (let ((fn (substring buff-name 5 (1- len))))
	 ;(gud-display-line fn line)
	 (let* ((buffer
		 (with-current-buffer gud-comint-buffer
		   (gud-find-file fn)))
		(window (and buffer (or (get-buffer-window buffer)
					(if (memq gud-minor-mode '(gdbmi gdba))
					    (unless (gdb-display-source-buffer buffer)
					      (gdb-display-buffer buffer nil)))
					(display-buffer buffer)))))
	   (if (and enabled (not (eq line 0)))
	       (with-current-buffer eip-perl-db-buffer
		 (goto-line line)
		 (if (and (< (point) (point-max))
			  (not (eq (line-beginning-position) (line-end-position))))
		     (eip-put-string nil (1+ (line-beginning-position))
				     `(left-fringe breakpoint breakpoint-enabled string)
				     'eip-perldb-break t))
		 )
	     (with-current-buffer eip-perl-db-buffer
	       (if (= line 0)
		   (save-excursion
		     (save-restriction
		       (widen)
		       (let ((es (overlays-in 1 (1+ (point-max)))))
			 (mapc (lambda (e) 
				 (if t
				     (delete-overlay e)))
			       es))))
		 (progn
		   (goto-line line)
		   (let ((overlays (overlays-at (1+ (line-beginning-position))))
			 (non-exist t)
			 o)
		     (if overlays
			 (progn
			   (while (and (setq o (pop overlays)) non-exist)
			     (if (overlay-get o 'eip-perldb-break)
				 (progn
				   (delete-overlay o)
			       (setq non-exist t)))))))))
		 ))
	   ))))
   )

(defun eip-set-breakpoint (args)
  (cond ((string= (car args) "b")
	 (eip-display-breakpoint t (string-to-number (nth 1 args)))
	 )
	((string= (car args) "B")
	 (if (= (string-to-number (nth 1 args)) 0)
	     ;; check whether '*'
	     (if (string= (nth 1 args) "*")
		 (eip-display-breakpoint nil 0))
	   (eip-display-breakpoint nil (string-to-number (nth 1 args)))))))


(defun eip-perl-comint-send-input (&optional no-newline artificial)
  (interactive)
  (if (eq gud-marker-filter 'gud-perldb-marker-filter)
  (let ((proc (get-buffer-process (current-buffer))))
    (if (not proc) (error "Current buffer has no process")
      (widen)
      (let* ((pmark (process-mark proc))
	       (intxt (if (>= (point) (marker-position pmark))
			  (progn (if comint-eol-on-send (end-of-line))
				 (buffer-substring pmark (point)))
			(let ((copy (funcall comint-get-old-input)))
			  (goto-char pmark)
			  (insert copy)
			  copy)))
	       (args (split-string intxt)))
	(eip-set-breakpoint args)
	))))
    (comint-send-input no-newline artificial))


(define-key gud-minor-mode-map [left-fringe mouse-1]
  'gdb-mouse-set-clear-breakpoint)

(define-key gud-minor-mode-map [f8] 'gud-next)
(define-key gud-minor-mode-map [f7] 'gud-step)
(define-key gud-minor-mode-map [f5] 'gud-cont)
(define-key gud-minor-mode-map [return] 'eip-perl-comint-send-input)
(provide 'eip_perldb-gui)